home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Taifun / Taifun 099 (1989-05-15)(Ossowski, Stefan)(DE)(PD).zip / Taifun 099 (1989-05-15)(Ossowski, Stefan)(DE)(PD).adf / PCQ / Source / Calls.p next >
Text File  |  1989-03-31  |  14KB  |  495 lines
  1. external;
  2.  
  3. {
  4.     Calls.p (of PCQ Pascal)
  5.     Copyright (c) 1989 Patrick Quaid
  6.  
  7.     Calls.p is the first attempt to organize the various
  8. addressing and code generating routines in one section.  If you
  9. read the other sections you'll find that not much effort went into
  10. this project.  Nonetheless, a couple of common addressing things
  11. can be found here.
  12.     If the compiler were designed so that all the addressing
  13. things were here, it would be much easier to port to a different
  14. computer.
  15. }
  16.  
  17. const
  18. {$I "pasconst.i"}
  19.  
  20. type
  21. {$I "pastype.i"}
  22.  
  23. var
  24. {$I "pasvar.i"}
  25.  
  26.     function match(s : integer) : boolean;
  27.         forward;
  28.     procedure error(s : string);
  29.         forward;
  30.     function findfield(s : string; p : integer): integer;
  31.         forward;
  32.     procedure nextsymbol;
  33.         forward;
  34.     function expression() : integer;
  35.         forward;
  36.     function typecheck(t1, t2 : integer): boolean;
  37.         forward;
  38.     function typecmp(t1, t2 : integer) : boolean;
  39.         forward;
  40.     function findid(s : string) : integer;
  41.         forward;
  42.     function isvariable(i : integer) : boolean;
  43.         forward;
  44.     function getlabel() : integer;
  45.         forward;
  46.     procedure printlabel(l : integer);
  47.         forward;
  48.     procedure ns;
  49.         forward;
  50.     function suffix(s : integer): char;
  51.         forward;
  52.     procedure mismatch;
  53.         forward;
  54.     function basetype(t : integer): integer;
  55.         forward;
  56.     function simpletype(t : integer): boolean;
  57.         forward;
  58.     function numbertype(t : integer): Boolean;
  59.         forward;
  60.     procedure promotetype(var f : integer; o, r : integer);
  61.         forward;
  62.  
  63. procedure dorangecheck(vartype : integer);
  64.  
  65. {
  66.     This routine is called from selector() when range checking
  67. is turned on.  Notice that the code is all inline, rather than
  68. calling some library function.  I see this as a debugging option,
  69. so I didn't try very hard to optimize it.
  70. }
  71.  
  72. var
  73.     safelabel : integer;
  74.     badlabel  : integer;
  75. begin
  76.     if idents[vartype].offset = varray then begin
  77.     safelabel := getlabel();
  78.     badlabel := getlabel();
  79.     writeln(output, "\tcmp.l\t#", idents[vartype].lower, ',d0');
  80.     write(output, "\tblt.s\t");
  81.     printlabel(badlabel);
  82.     writeln(output, "\n\tcmp.l\t#", idents[vartype].upper, ',d0');
  83.     write(output, "\tbgt.s\t");
  84.     printlabel(badlabel);
  85.     write(output, "\n\tbra.s\t");
  86.     printlabel(safelabel);
  87.     writeln(output);
  88.     printlabel(badlabel);
  89.     writeln(output, "\tmove.l\t#52,d0");
  90.     writeln(output, "\tjsr\t_p%exit");
  91.     printlabel(safelabel);
  92.     writeln(output);
  93.     end;
  94. end;
  95.  
  96. procedure getpointerval(varindex : integer);
  97.  
  98. {
  99.     This routine puts the value of a pointer variable (or a
  100. reference parameter) into d0.
  101. }
  102.  
  103. begin
  104.     if idents[varindex].object = global then
  105.     writeln(output, "\tmove.l\t_", idents[varindex].name, ',d0');
  106.     else if idents[varindex].object = refarg then begin
  107.     writeln(output, "\tmove.l\t", idents[varindex].offset, '(a5),a0');
  108.     writeln(output, "\tmove.l\t(a0),d0");
  109.     end else
  110.     writeln(output, "\tmove.l\t", idents[varindex].offset, '(a5),d0');
  111. end;
  112.  
  113. procedure simpleaddress(varindex : integer);
  114.  
  115. {
  116.     simpleaddress() is passed a idrecord of some sort of
  117. variable, and just loads its address into a0.
  118. }
  119.  
  120. begin
  121.     if idents[varindex].object = global then
  122.     writeln(output, "\tmove.l\t#_", idents[varindex].name, ',a0');
  123.     else if (idents[varindex].object = local)
  124.         or (idents[varindex].object = valarg) then
  125.     writeln(output, "\tlea\t", idents[varindex].offset, '(a5),a0');
  126.     else if idents[varindex].object = refarg then
  127.     writeln(output, "\tmove.l\t", idents[varindex].offset, '(a5),a0');
  128. end;
  129.  
  130. function selector(varindex : integer) : integer;
  131.  
  132. {
  133.     This is an overlarge function that handles all the
  134. selectors- in other words ^, ., and [].  It can handle a series of
  135. them, of course.  selector() returns 0 if no selection was
  136. required, and the type if there was some selection.  This routine
  137. will be split up, and I'm planning to add addressing for strings
  138. like that in C.
  139. }
  140.  
  141. var
  142.     vartype    : integer;
  143.     typeindex    : integer;
  144.     indextype    : integer;
  145.     stacked    : boolean;
  146.     bufsize    : integer;
  147. begin
  148.     stacked := false;
  149.     vartype := idents[varindex].vtype;
  150.     while (currsym = period1) or (currsym = leftbrack1) or
  151.       (currsym = carat1) do begin
  152.     if match(period1) then begin
  153.         if idents[vartype].offset <> vrecord then
  154.         error("not a record type");
  155.         typeindex := findfield(symtext, vartype);
  156.         if typeindex = 0 then
  157.         error("unknown field");
  158.         nextsymbol;
  159.         if idents[typeindex].offset <> 0 then begin
  160.         if stacked then
  161.             write(output, "\tadd.l\t#")
  162.         else
  163.             write(output, "\tmove.l\t#");
  164.         writeln(output, idents[typeindex].offset, ',d0');
  165.         end else if not stacked then
  166.         writeln(output, "\tmoveq\t#0,d0");
  167.         stacked := true;
  168.         vartype := idents[typeindex].vtype;
  169.     end else if match(carat1) then begin
  170.         if idents[vartype].offset = vfile then begin
  171.         if stacked then
  172.             writeln(output, "\tmove.l\td0,a0")
  173.         else begin
  174.             simpleaddress(varindex);
  175.             stacked := true;
  176.         end;
  177.         bufsize := idents[vartype].vtype;
  178.         bufsize := idents[bufsize].size;
  179.         if (bufsize <= 4) and (bufsize <> 3) then begin
  180.             writeln(output, "\tlea\t4(a0),a0");
  181.             writeln(output, "\tmove.l\ta0,d0");
  182.         end else
  183.             writeln(output, "\tmove.l\t4(a0),d0");
  184.         vartype := idents[vartype].vtype;
  185.         end else if idents[vartype].offset = vpointer then begin
  186.         if stacked then begin
  187.             writeln(output, "\tmove.l\td0,a0");
  188.             writeln(output, "\tmove.l\t(a0),d0");
  189.         end else
  190.             getpointerval(varindex);
  191.         stacked := true;
  192.         vartype := idents[vartype].vtype;
  193.         end else
  194.         error("Need a file or pointer for ^");
  195.     end else if match(leftbrack1) then begin
  196.         if idents[vartype].offset <> varray then
  197.         error("not an array");
  198.         if stacked then
  199.         writeln(output, "\tmove.l\td0,-(sp)");
  200.         indextype := expression();
  201.         promotetype(indextype, inttype, 0);
  202.         if rangecheck then
  203.         dorangecheck(vartype);
  204.         if not typecheck(indextype, idents[vartype].indtype) then
  205.         mismatch;
  206.         if not match(rightbrack1) then
  207.         error("expecting ]");
  208.         if idents[vartype].lower <> 0 then
  209.         writeln(output, "\tsub.l\t#", idents[vartype].lower, ',d0');
  210.         vartype := idents[vartype].vtype;
  211.         if idents[vartype].size <> 1 then
  212.         writeln(output, "\tmuls\t#", idents[vartype].size, ',d0');
  213.         if stacked then begin
  214.         writeln(output, "\tmove.l\t(sp)+,d1");
  215.         writeln(output, "\tadd.l\td1,d0");
  216.         end    else
  217.         stacked := true;
  218.     end;
  219.     end;
  220.     if stacked then
  221.     selector := vartype
  222.     else
  223.     selector := 0;
  224. end;
  225.  
  226. function loadvar(varindex : integer) : integer;
  227.  
  228. {
  229.     This routine is used in assignments.  If the variable
  230. reference requires selection, loadvar() loads the address into d0
  231. and returns the appropriate type.  If not, it does not load the
  232. address, and returns zero.
  233. }
  234.  
  235. var
  236.     vartype        : integer;
  237.     originaltype    : integer;
  238. begin
  239.     nextsymbol;
  240.     vartype := selector(varindex);
  241.     originaltype := idents[varindex].vtype;
  242.     if vartype = 0 then
  243.     loadvar := 0
  244.     else begin
  245.     if (idents[originaltype].offset <> vpointer) and
  246.        (idents[originaltype].offset <> vfile) then begin
  247.         simpleaddress(varindex);
  248.         writeln(output, "\tadd.l\ta0,d0");
  249.     end;
  250.     loadvar := vartype;
  251.     end;
  252. end;
  253.  
  254. function loadaddress() : integer;
  255.  
  256. {
  257.     This is the routine used wherever I need the address of a
  258. variable, for example reference parameters or the adr() function.
  259. The address is loaded into a0.
  260. }
  261.  
  262. var
  263.     argindex    : integer;
  264.     argtype    : integer;
  265.     bt        : integer;
  266. begin
  267.     if currsym = ident1 then begin
  268.     argindex := findid(symtext);
  269.     nextsymbol;
  270.     if argindex = 0 then begin
  271.         error("Unknown ID");
  272.         argindex := badtype;
  273.     end else begin
  274.         if isvariable(argindex) then begin
  275.         argtype := selector(argindex);
  276.         bt := basetype(idents[argindex].vtype);
  277.         if argtype = 0 then begin
  278.             simpleaddress(argindex);
  279.             argtype := idents[argindex].vtype
  280.         end else begin
  281.             if (idents[bt].offset = vpointer) or
  282.             (idents[bt].offset = vfile) then
  283.             writeln(output, "\tmove.l\td0,a0");
  284.             else begin
  285.             simpleaddress(argindex);
  286.             writeln(output, "\tadda.l\td0,a0");
  287.             end;
  288.         end;
  289.         loadaddress := argtype;
  290.         end else
  291.         if argindex <> badtype then
  292.             error("expecting a variable (reference parameter)");
  293.     end
  294.     end else
  295.     error("expecting a variable identifier");
  296.     loadaddress := badtype;
  297. end;
  298.  
  299. procedure getparams(procindex : integer);
  300.  
  301. {
  302.     This routine handles the parameters of a call (not the
  303. declaration, which is handled in doblock()).  It sorts out the
  304. various reference and value parameters and gets the stack properly
  305. set up.
  306. }
  307.  
  308. var
  309.     currentparam    : integer;
  310.     stay        : boolean;
  311.     argtype        : integer;
  312.     argindex        : integer;
  313.     totalsize        : integer;
  314.     lab            : integer;
  315. begin
  316.     stay := true;
  317.     if match(leftparent1) then begin
  318.     currentparam := idents[procindex].indtype;
  319.     while (not match(rightparent1)) and stay do begin
  320.         if currentparam = 0 then begin
  321.         error("argument not expected");
  322.         nextsymbol;
  323.         stay := false;
  324.         end else begin
  325.         if idents[currentparam].object = valarg then begin
  326.             argtype := expression();
  327.             if not typecheck(argtype, idents[currentparam].vtype)
  328.                 then begin
  329.             mismatch;
  330.             argtype := badtype;
  331.             end else begin
  332.             if numbertype(argtype) then
  333.                 promotetype(argtype, idents[currentparam].vtype, 0);
  334.             argtype := idents[currentparam].vtype;
  335.             if simpletype(argtype) then begin
  336.                 if idents[argtype].size <= 2 then
  337.                 writeln(output, "\tmove.w\td0,-(sp)")
  338.                 else if idents[argtype].size = 4 then
  339.                 writeln(output, "\tmove.l\td0,-(sp)");
  340.             end else begin
  341.                 writeln(output, "\tmove.l\td0,a0");
  342.                 writeln(output, "\tmove.l\tsp,a1");
  343.                 writeln(output, "\tsub.l\t#",
  344.                 idents[argtype].size, ',a1');
  345.                 writeln(output, "\tmove.l\t#",
  346.                 idents[argtype].size - 1, ',d1');
  347.  
  348.                 lab := getlabel();
  349.                 printlabel(lab);
  350.                 writeln(output, "\tmove.b\t(a0)+,d0");
  351.                 writeln(output, "\tmove.b\td0,(a1)+");
  352.                 write(output, "\tdbra\td1,");
  353.                 printlabel(lab);
  354.                 writeln(output);
  355.                 write(output, "\tsub.l\t#");
  356.                 if odd(idents[argtype].size) then
  357.                 write(output, idents[argtype].size + 1)
  358.                 else
  359.                 write(output, idents[argtype].size);
  360.                 writeln(output, ',sp');
  361.             end;
  362.             end;
  363.         end else if idents[currentparam].object = refarg then begin
  364.             if currsym = ident1 then begin
  365.             argtype := loadaddress();
  366.             writeln(output, "\tmove.l\ta0,-(sp)");
  367.             if not typecmp(argtype, idents[currentparam].vtype)
  368.                     then
  369.                 mismatch;
  370.             end else
  371.             error("Expecting a variable name (reference param)");
  372.         end;
  373.         currentparam := idents[currentparam].indtype;
  374.         if currentparam <> 0 then
  375.             if not match(comma1) then
  376.             error("expected ,");
  377.         end;
  378.     end;
  379.     if currentparam <> 0 then
  380.         error("more parameters needed");
  381.     end else begin
  382.     if idents[procindex].indtype <> 0 then
  383.         error("expecting some parameters")
  384.     else if idents[procindex].object = func then
  385.         error("expecting parentheses for a function");
  386.     end
  387. end;
  388.  
  389. procedure callproc(varindex : integer);
  390.  
  391. {
  392.     This routine makes an actual call to a procedure.  In the
  393. next version this routine will have to push an extra address, which
  394. will point to the routine's parent's frame pointer.  Never mind
  395. about that except that it is required in order to properly
  396. implement nested blocks.
  397. }
  398.  
  399. begin
  400.     nextsymbol;
  401.     getparams(varindex);
  402.     ns;
  403.     writeln(output, "\tjsr\t_", idents[varindex].name);
  404.     if idents[varindex].size <> 0 then
  405.     writeln(output, "\tadd.l\t#", idents[varindex].size, ',sp');
  406. end;
  407.  
  408. procedure callfunc(varindex : integer);
  409.  
  410. {
  411.     This calls a function.  It's mostly the same as callproc,
  412. but it's called from deep within expression() rather than
  413. statement().  This will also have to push a back pointer.
  414. }
  415.  
  416. begin
  417.     getparams(varindex);
  418.     writeln(output, "\tjsr\t_", idents[varindex].name);
  419.     if idents[varindex].size <> 0 then
  420.     writeln(output, "\tadd.l\t#", idents[varindex].size, ',sp');
  421. end;
  422.  
  423. procedure savethrougha0(totalsize : integer);
  424.  
  425. {
  426.     This saves a complex data object pointed to by d0 to the
  427. memory at a0.
  428. }
  429.  
  430. var
  431.     lab        : integer;
  432. begin
  433.     writeln(output, "\tmove.l\td0,a1");
  434.     writeln(output, "\tmove.l\t#", totalsize - 1, ',d1');
  435.     lab := getlabel();
  436.     printlabel(lab);
  437.     writeln(output, "\tmove.b\t(a1)+,d0");
  438.     writeln(output, "\tmove.b\td0,(a0)+");
  439.     write(output, "\tdbra\td1,");
  440.     printlabel(lab);
  441.     writeln(output);
  442. end;
  443.  
  444. procedure savestack(typeindex : integer);
  445.  
  446. {
  447.     This saves a variable into the memory pointed to by the
  448. longword on the top of the stack.  Odd as it may sound, this occurs
  449. fairly often.
  450. }
  451.  
  452. begin
  453.     writeln(output, "\tmove.l\t(sp)+,a0");
  454.     if simpletype(typeindex) then
  455.     writeln(output, "\tmove.", suffix(idents[typeindex].size), "\td0,(a0)");
  456.     else
  457.     savethrougha0(idents[typeindex].size);
  458. end;
  459.  
  460. procedure saveval(varindex : integer);
  461.  
  462. {
  463.     This saves whatever's in d0 into the variable pointed to by
  464. varindex.
  465. }
  466.  
  467. var
  468.     totalsize    : integer;
  469. begin
  470.     totalsize := idents[varindex].vtype;
  471.     totalsize := idents[totalsize].size;
  472.     if idents[varindex].object = global then begin
  473.     if not simpletype(idents[varindex].vtype) then begin
  474.         writeln(output, "\tmove.l\t#_", idents[varindex].name, ',a0');
  475.         savethrougha0(totalsize);
  476.     end else
  477.         writeln(output, "\tmove.", suffix(totalsize), "\td0,_",
  478.             idents[varindex].name);
  479.     end else if (idents[varindex].object = local) or
  480.         (idents[varindex].object = valarg) then begin
  481.     if not simpletype(idents[varindex].vtype) then begin
  482.         writeln(output, "\tlea\t", idents[varindex].offset, '(a5),a0');
  483.         savethrougha0(totalsize);
  484.     end else
  485.         writeln(output, "\tmove.", suffix(totalsize), "\td0,",
  486.             idents[varindex].offset, '(a5)');
  487.     end else begin
  488.     writeln(output, "\tmove.l\t", idents[varindex].offset, '(a5),a0');
  489.     if not simpletype(idents[varindex].vtype) then
  490.         savethrougha0(totalsize)
  491.     else
  492.         writeln(output, "\tmove.", suffix(totalsize), "\td0,(a0)");
  493.     end;
  494. end;
  495.